Исходный код

'==============================================================================
' Выполнить выбранные пользователем действия над коллекцией статусов объекта.
' Выполнять скрипт может только системный администратор
'==============================================================================
Sub WorkWithStatuses(Obj)
        
        Dim SelDlg, RetVal, strAction, ArActions, StatCol
        
        ArActions = Array("Добавить статус", "Изменить статус объекта на конечный", _
                                "Удалить статус", "Вывести информацию о допустимых статусах объекта")
        
        'Предоставить пользователю выбрать действие 
        Set SelDlg = ThisApplication.Dialogs.SelectDlg
        SelDlg.SelectFrom = ArActions 
        SelDlg.Prompt = "Выберите действие:"
        RetVal = SelDlg.Show
        
        'Если пользователь отменил диалог или ничего не выбрал, закончить работу.
        'Диалог вернул массив, поскольку был инициализирован строковым массивом
        If (RetVal <> TRUE) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
        
        'ПОлучить ссылку на коллекцию статусов объекта
        Set StatCol = Obj.ObjectDef.Statuses
        
        'Выполнить все заданные действия
        For Each strAction In SelDlg.Objects
                If StrComp(strAction, ArActions(0))=0 Then
                                                                                            Call AddStatus(StatCol)
                ElseIf StrComp(strAction, ArActions(1))=0 Then
                                                                                            Call SetFinalStatus(StatCol, Obj)
                ElseIf StrComp(strAction, ArActions(2))=0 Then
                                                                                            Call RemoveStatus(StatCol)
                ElseIf StrComp(strAction, ArActions(3))=0 Then
                                                                                            Call ShowInfo(StatCol)
                End If
        Next
End Sub
'==============================================================================


'==============================================================================
'Добавить новый статус в коллекцию
'==============================================================================
Sub AddStatus(StatCol)

        Dim i, Stat, SelDlg, RetVal 
        
        'Заполнить массив ссылками на статусы, созданные в приложении (кроме тех,
        'которые уже есть у объекта)
        i=-1
        For Each Stat In ThisApplication.Statuses
                If Not StatCol.Has(Stat) Then
                        i=i+1
                        ReDim Preserve ArStatus(i)
                        Set ArStatus(i) = Stat
                End If
        Next
        
        'Открыть диалог выбора, передав на вход массив допустимых статусов
        Set SelDlg = ThisApplication.Dialogs.SelectDlg
        SelDlg.SelectFrom = ArStatus
        SelDlg.Caption = "Допустимые статусы для добавления"
        SelDlg.Prompt = "Выберите статус:"
        RetVal = SelDlg.Show
        
        'Если пользователь ничего не выбрал или отменил диалог, выйти из процедуры
        If (Not RetVal) Or (UBound(SelDlg.Objects)<0) Then Exit Sub
        
        'Включим собственный перехват ошибок
        On Error Resume Next                        
        
        'Добавить выбранные статусы в коллекцию статусов объектов данного типа
        For Each Stat In SelDlg.Objects
                StatCol.Add Stat 
        
                'Если была ошибка...
                If Err<>0 Then         
                        MsgBox "Ошибка добавления статуса " & StrSysName & "." &_
                                        Chr(13) & "Код ошибки: " & Err, vbExclamation
                        Err=0
                End If
        Next
End Sub
'==============================================================================


'==============================================================================
'Изменить текущий статус объекта на конечный. Для этого все объекты состава
'должны также иметь конечный статус.
'==============================================================================
Sub SetFinalStatus(StatCol, Obj)

        Dim FinalStat, Stat, ChildObj
        
        'Если хотя бы один объект состава не имеет конечного статуса, сообщить 
        'об этом и выйти из процедуры
        For Each ChildObj In Obj.Content
                If ChildObj.Status.Final<>TRUE Then
                        MsgBox "Смена статуса невозможна" & Chr(13) &_
                                    "(не все объекты состава имеют конечный статус.)", vbExclamation
                        Exit Sub
                End If
        Next
        
        'Ищем, какой статус у данного объекта конечный...
        Set FinalStat = Nothing
        For Each Stat In StatCol
                If Stat.Final=TRUE Then
                        Set FinalStat = Stat
                        Exit For
                End If
        Next
        
        'На всякий случай проверим - вдруг в коллекции не было "финального" статуса...
        If FinalStat Is Nothing Then
                MsgBox "Конечный статус не найден в коллекции." , vbExclamation
                Exit Sub
        End If
        
        'Включим собственный перехват ошибок
        On Error Resume Next                        

        'Пробуем сменить статус объекта.
        Obj.Permissions = SysAdminPermissions
        Obj.Status = FinalStat
        
        'Если была ошибка...
        If Err<>0 Then         MsgBox "Ошибка изменения статуса " & StrSysName & "." &_
                                Chr(13) & "Код ошибки: " & Err, vbExclamation
End Sub
'==============================================================================


'==============================================================================
'Удалить статус из коллекции
'==============================================================================
Sub RemoveStatus(StatCol)

        Dim StrRet, index, Stat, RetVal
        
        'Запросить индекс статуса для удаления. Он не должен превышать количество 
        'статусов в коллекции
        StrRet = InputBox("Введите индекс статуса, который должен быть удален:" & Chr(13) &_
                         "(от 0 до " & StatCol.Count-1 & "):")
        
        'Если введено не-число или диалог отменен, выйти из процедуры
        If (StrRet="") Or (Not IsNumeric(StrRet)) Then Exit Sub
        
        'Получить введенный индекс
        index = CLng(StrRet)
        
        'Возможно, введенное число выходит за границы допустимого диапазона
        If Not StatCol.Has(index) Then
                MsgBox "Задан недопустимый индекс.", vbExclamation
                Exit Sub
        End If
        
        'Запросить подтверждение удаления
        Set Stat = StatCol.Item(index)
        RetVal =     MsgBox("Удалить статус """ & Stat.Description & """?", vbQuestion + vbYesNo)    
        
        'Если подтверждения нет, выйти из процедуры
        If RetVal <> vbYes Then Exit Sub
        
        'Попытаться удалить статус. Включим собственный перехват ошибок
        On Error Resume Next
        
        'Удалить статус из коллекции
        StatCol.Remove(Stat)
        
        'Если ошибка, сообщить об этом
        If Err<>0 Then        MsgBox "Ошибка удаления статуса """ & Stat.Description & """." _
                            & Chr(13)    & "Код ошибки: " & Err, vbExclamation     
End Sub
'==============================================================================

'==============================================================================
' Вывести информацию обо всех статусах объекта
'==============================================================================
Sub ShowInfo(StatCol)
        Dim StrInfo, Stat, RoleDef
        
        For Each Stat In StatCol
        With Stat 
                StrInfo = .Description & Chr(13)
                StrInfo = StrInfo & "Системное имя: " & .SysName & Chr(13)
                StrInfo = StrInfo & "Конечный: " & .Final & Chr(13)
                StrInfo = StrInfo & "Независимый: " & .Independent & Chr(13)
                
                'Вывести информацию в окно сообщений
                ThisApplication.AddNotify(StrInfo)
        End With
        Next
        
End Sub
'==============================================================================